Fun & Games 2 (Canada)/Fun & Games CD-ROM (Canada).bin/games/disk150/ls.pas

Pascal/Delphi Source File | 1989-06-23 | 8.2 KB | 394 lines

program Lettershift;
{ programmed by    Konstantin Articus
                   Gross strasse 21
                   2250 Husum
                   West Germany

  This game is Public Domain.
  You may change it for your own purpose,
  but please share it unmodified.

  possible parameters: F for faster shuffling
                       M for monochrom monitor

  last changes: 23.6.1989 }

uses crt,dos;

var
again,i,index,indicator,shuffl,OldDir,empty:integer;
finished,faster,mono:boolean;
color:byte;
regs:registers;
place:array[1..16] of string[1];
result :array[1..4] of integer;
moves,number:real;


procedure CursorOn;

begin
  regs.ah:=1;
  regs.ch:=6;
  regs.cl:=7;
  intr($10,regs);
end;


procedure CursorOff;

begin
  regs.ah:=1;
  regs.ch:=15;
  regs.cl:=1;
  intr($10,regs);
end;

procedure Error (errmsg:string);

begin
  if mono=false then textcolor(red);
  writeln(#7,errmsg);
  if mono=false then textcolor (black);
end;


procedure SlowDownLoop;

var a,loop:integer;

begin
if faster=false then for loop:=1 to 6500 do a:=1;
end;


procedure WriteAt (x,y:integer;msg:string);

begin
  gotoxy(x,y);
  writeln (msg);
end;


procedure DeleteLine (y:integer);

begin
  gotoxy (1,y);
  clreol;
end;


procedure ScreenSetUp;

var line:shortint;
    plus:shortint;

begin
  SlowDownLoop;
  begin
    gotoxy  (20,24);
    writeln ('No. of moves: ',moves:3:0);
    if mono = false then
    begin
      textbackground (brown);
      textcolor (white);
    end;
    if mono = false then plus:=0 else plus:=-1;
    WriteAt (20+plus,3,' Letter Shift ');
    WriteAt (20,5,'╔═══╦═══╦═══╦═══╗');
    gotoxy (20,6);
    writeln ('║ ',place[1],' ║ ',place[2],' ║ ',place[3],' ║ ',place[4],' ║');
    WriteAt (20,7,'╠═══╬═══╬═══╬═══╣');
    gotoxy (20,8);
    writeln ('║ ',place[5],' ║ ',place[6],' ║ ',place[7],' ║ ',place[8],' ║');
    WriteAt (20,9 ,'╠═══╬═══╬═══╬═══╣');
    gotoxy (20,10);
    writeln ('║ ',place[9],' ║ ',place[10],' ║ ',place[11],' ║ ',place[12],' ║');
    WriteAt (20,11,'╠═══╬═══╬═══╬═══╣');
    gotoxy (20,12);
    writeln ('║ ',place[13],' ║ ',place[14],' ║ ',place[15],' ║ ',place[16],' ║');
    WriteAt (20,13,'╚═══╩═══╩═══╩═══╝');
    if mono= false then begin
    textcolor (black);
    textbackground (white);
    WriteAt (21,4,'▀▀▀▀▀▀▀▀▀▀▀▀▀▀');
    WriteAt (34,3,'▄');
    WriteAt (22,14,'▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀');
    for line:= 1 to 8 do
    begin
      WriteAt (37,line+5,'█');
    end;
end;  end;
end;



function PlayAgain:boolean;

var ch:char;

begin
  DeleteLine (22);
  WriteAt (20,21,'Play again ?');
  repeat
    gotoxy (20,22);
    clreol;
    cursorOn;
    ch:=readkey;
    cursoroff;
    ch:=upcase (ch);
    if not (ch  in ['Y','N']) then
    begin
      gotoxy (20,23);
      error ('Please press Y or N !');
    end;
  until ch in ['Y','N'];
  DeleteLine (21);DeleteLine (18);DeleteLine (23);
  if ch='N' then
  begin
    textmode (lastmode);
    textattr :=color;
    clrscr;
    WriteAt (1,2,'Send me a postcard, if you like the game.');
    WriteAt (1,3,'Auf Wiedersehen !');
  end;

    if ch='Y' then PlayAgain:=true else PlayAgain:=false;
end;


procedure stop;

begin
  index:=-1;
  gotoxy (20,16);
  writeln (#7,'I don`t believe that you can finish the game !       ');
  DeleteLine (17);
  finished:=true;
end;


procedure PossibleDirections;

var r:shortint;

begin
  result[1]:= indicator -4;
  result[2]:= indicator +4;
  result[3]:= indicator +1;
  result[4]:= indicator -1;
  for r:=1 to 4 do
  if (result[r] >16 ) or (result [r] <1) then result [r]:=-1;
  case indicator of
    4: result[3]:=-1;
    5: result[4]:=-1;
    8: result[3]:=-1;
    9: result[4]:=-1;
   12: result[3]:=-1;
   13: result[4]:=-1;
  end;
end;



procedure Input;

var
wahl:char;
direction:integer;

begin
  repeat
    DeleteLine (17);
    WriteAt (20,16,'Which letter should be moved ? (Q = Quit)           ');
    repeat
      gotoxy (20,17);
      clreol;
      cursoron;
      wahl := readkey;
      cursoroff;
      wahl:=upcase (wahl);
      gotoxy(1,18);clreol;
      if not (wahl in ['Q','A'..'O'] )then
      begin
        gotoxy(20,18);
        error ('Please choose from A up to O or Q !           ');
      end;
    until wahl in ['Q','A'..'O'] ;
    direction:=-1;
    if wahl='Q' then
    begin
      index:=-1;
      WriteAt (20,16,'You don`t know how to proceed ?                       ');
      WriteAt (20,17,'Nor do I !                                  ');
    end;
    if wahl = 'Q' then exit;
    for i:= 1 to 16 do if place[i]=wahl then indicator:=i;
    PossibleDirections;
    for i:=1 to 4 do if empty=result[i] then direction:=empty;
    if direction = -1 then
    begin
      gotoxy(20,18);
      error ('You can`t move that letter yet !                      ');
    end;
  until direction <> -1;
  place [direction]:=place[indicator];
  place [indicator]:=' ';
  empty:=indicator;
end;


function managed:boolean;

var ready:boolean;
    sequence:string;
    j:integer;

begin
  ready:=false;
  sequence:='';
  for j:= 1 to 16 do sequence:= sequence+ place[j];
  if sequence = 'ABCDEFGHIJKLMNO ' then ready:=true;
  if ready=true then
  begin
    WriteAt (20,16,'You managed it !                                     ');
    number:=(moves*100)/shuffl;
    gotoxy (20,17);
    writeln ('You needed ',number:1:0,'% of the number of   ');
    WriteAt (20,18,'moves the computer used to shuffle !       ');
  end;
  managed:=ready;
end;


procedure schuffle;

var inp2 :string;
i,inp,full,PossibleDir,code :integer;
wrong:boolean;
m:real;

begin
  WriteAt (20,16,'How often should I shuffle ?');
  gotoxy (48,16);clreol;
  repeat
    gotoxy (20,17);clreol;
    cursoron;
    readln (inp2);
    cursoroff;
    val (inp2,shuffl,code);
    if not ((shuffl>1) and (code=0) and (shuffl <201)) then
    begin
      DeleteLine (18);
      DeleteLine (19);
      gotoxy (20,18);
      error ('Please input an integer number between 2 and 200 !');
    end;
  until (shuffl>1) and (code=0) and (shuffl <201);
  DeleteLine (18);
  WriteAt (20,19,'Shuffling - please wait !  ');
  for I:= 1 to shuffl do
  begin
    repeat
      repeat
        wrong:= false;
        PossibleDir:=round (random(4)+1);
        if PossibleDir = OldDir then wrong:=true;
      until wrong= false;
      indicator:=empty;
      PossibleDirections;
    until result [PossibleDir]<>-1;
    full:=result [PossibleDir];
    place [empty]:=place[full];
    place [full]:=' ';
    empty:=full;
    ScreenSetUp;
    if PossibleDir= 1 then OldDir:=2;
    if PossibleDir= 2 then OldDir:=1;
    if PossibleDir= 3 then OldDir:=4;
    if PossibleDir= 4 then OldDir:=3;
    gotoxy(40,24);
    Writeln (i:3,' times shuffled !');
  end;
  DeleteLine (19);
end;


procedure parameter;

var dummy:string;

begin
  dummy:='';
  faster:=false;
  mono:=false;
  for I:= 1 to paramcount do dummy:=dummy+paramstr (i);
  for i:= 1 to length (dummy) do
  begin
    if upcase(dummy[i])='F' then faster:=true;
    if upcase(dummy[i])='M' then mono:=true;
  end;
end;

procedure Initialisation;

begin
  if again<> 2 then
  begin
    parameter;
    if  mono =  false then
    begin
      textmode (co80);
      textbackground (White);
      textcolor (black);
      clrscr;
    end
    else textmode (BW80);
    clrscr;
    cursoroff;
    WriteAt(44,3,'programmed by');
    WriteAt(44,5,'Konstantin Articus');
    WriteAt(44,6,'Gross strasse 21');
    WriteAt(44,7,'2250 Husum');
    WriteAt(44,8,'West Germany');
  end;
  randomize;
  OldDir:=0;
  for i :=1 to 16 do
  begin
    place[i]:=chr(64+i);
  end;
  place[16]:=' ';
  finished:=false;
  empty:=16;
  index:=0;
  moves:=0;
  ScreenSetUp;
  gotoxy(40,24);
  writeln (0:3,' times shuffled !');
end;


begin
  color:=textattr;
  again:=1;
  repeat
    Initialisation;
    again:=2;
    schuffle;
    repeat
      moves:=moves+1;
      Input;
      if index<>-1 then
      begin
        ScreenSetUp;
        finished:=managed;
        if moves =999 then stop;
      end
      else finished:=true;
    until finished = true;
  until PlayAgain =false;
end.